perm filename QFUNC.F4[MUS,LCS] blob
sn#102043 filedate 1974-05-10 generic text, type T, neo UTF8
00100 COMMON XS(100),YS(100),N,X1(512),Y1(512),S(100),K
00200 COMMON/RD/TM(50),SP1(50),SP2(50),SFAC(512)
00220 DIMENSION A(50,2)
00300 21 FORMAT(' F=FINISH - '$)
00400 26 FORMAT(I3,') TYPE X# AND Y# - OR L=LTPEN. X=EXIT-- '$)
00500 280 FORMAT(' "A" IS AT -10,10'/)
00600 30 FORMAT(8F)
00700 37 FORMAT(8F9.3)
00800 371 FORMAT(I3,') ',4F8.2)
00900 40 FORMAT(A1)
01000 47 FORMAT(' C=CHNG, I=INSRT, D=DEL -- + LN# & CHNGS '$)
01100 2281 TYPE 280
01200 281 KZ=0
01300 ICUR=0
01400 C USED IN RELATIVE VECTOR ROUTINE
01500 1032 CALL ZERO(FUNC)
01600 C CLEARS THE FUNC.
01700 ISMOO=0
01800 GO TO 900
01900 210 KZ=KT
02000 Z=1
02100 GO TO 1032
02200
02300 900 CALL DPYQ
02400 800 X=0
02500 JT=2
02600 C JT AND EY SEEM TO PERFORM THE SAME FUNCTIONS??
02700 Y=0
02800 KT=1
02900 N=-256
03000 CALL DPYBRT(5)
03100 504 IF(KT.GE.KZ)GO TO 510
03200 AMP=A(KT,1)
03300 5008 STEP=A(KT,2)
03400 C SO IT CAN'T GO BACKWARDS
03500 GO TO 5071
03600 434 ICUR=0
03700 CALL CLRCUR
03800 GO TO 510
03900 C EXIT FROM CURSOR
04000 CC431 CALL SETCUR(0,0,0)
04100 431 NX=0
04200 NY=0
04300 NZ=0
04400 C TYPE <CR> HERE TO SET FIRST POINT AT 0,0
04500 ICUR=-1
04600 433 CALL SETCUR(NX,NY,NZ)
04700 NZ=1
04800 C =1 TO DRAG ALONG VECTOR
04900 TYPE 432,KT
05000 ACCEPT 40,AB
05100 IF(AB.EQ.'B')GO TO 509
05200 IF(AB.EQ.'R')GO TO 434
05300 IF(AB.EQ.'X')GO TO 7000
05400 MX=NX
05500 MY=NY
05600 CALL RDCUR(NX,NY)
05700 CC CALL SETCUR(NX,NY,1)
05800 STEP=NY/10.
05900 AMP=NX/10.
06000 5571 TYPE 37,AMP,STEP
06100 GO TO 5071
06200 611 FORMAT(' NO MORE THAN 50 SEGS'/)
06300 610 TYPE 611
06400 509 KT=KT-1
06500 CC IF(ICUR)CALL SETCUR(MX,MY,1)
06600 5091 IF(KT.LT.1)GO TO 281
06700 GO TO 210
06800 432 FORMAT(I3,') <CR>=SEG, B=BACKUP, R=RETURN '/)
06900 510 IF(ICUR)GO TO 433
07000 TYPE 26,KT
07100 KZ=0
07200 ACCEPT 40,BU
07300 IF(BU.EQ.'B')GO TO 509
07400 IF(BU.EQ.'L')GO TO 431
07500 61 REREAD 30,AMP,STEP,H
07600 IF(BU.EQ.'J')H=-1
07700 C IF H≠0 THEN JUMP
07800 C**********
07900 IF(BU.EQ.'X')GO TO 7000
08000 C******************
08100 5071 IF(KT.GT.50)GO TO 610
08200 C TOO MANY SEGS
08300 IF(Z.GT.0)TYPE 371,KT,AMP,STEP
08400 DIF=AMP-Y
08500 C SO IT CAN'T BACKUP HERE
08600 203 YSTP=STEP
08700 1203 JJX=X*10.
08800 NY=YSTP*10.
08900 NX=AMP*10.
09000 IF(KT.GT.1)GO TO 1202
09100 CALL AIVECT(NX,NY)
09200 GO TO 12
09300 1202 IZ=Y*10.
09400 CALL ALINE(JJX,IZ,NX,NY)
09500 CALL DPYOUT(1)
09600 12 X=AMP
09700 Y=YSTP
09800 A(KT,1)=X
09900 CC A(KT,2)=X
10000 A(KT,2)=STEP
10100 7001 KT=KT+1
10200 C KT COUNTS SEGMENTS
10300 GO TO 504
10400
10500 CC*************7000 IF(ISMOO)GO TO 201
10600 7000 IF(KT.LE.20)GO TO 7007
10700 TYPE 7008
10800 GO TO 509
10900 7008 FORMAT(' NO MORE THAN 20 SEGS IN CURVES'/)
11000 7007 J=KT-1
11100 CALL CLRCUR
11200 KX=0
11300 JL=0
11400 INC=4
11500 DO 1 K=1,J
11600 KXS=KXS+1
11700 XS(KXS)=A(K,1)
11800 1 YS(KXS)=A(K,2)
11900 9 XS(KXS+1)=999.
12000 4 N=KXS
12100 CALL SS
12200 JL=JL+1
12300 JK=JL
12400 CALL AIVECT(IFIX(XS(1)*10.),IFIX(YS(1)*10.))
12500 DO 5 K=2,512,INC
13000 5 CALL AVECT(IFIX(X1(K)*10.),IFIX(10.*Y1(K)))
13100 7009 CALL DPYOUT(1)
13200 CALL SPEED(X)
13300 IF(X)GO TO 509
15800 CC161 TYPE 21
15900 CC ACCEPT 40,K
16100 CC IF(K.EQ.'F')GO TO 2
16200 C FOR CHANGES
16300 3 IF(K.EQ.'B')GO TO 509
16400 2 CALL CLRCUR
16500 CALL QUADO
16600 CC GO TO 24
16800 GO TO 509
16900 C BACKS UP OUT OF SUBROUTINES.
17000 END